home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / source / cplasma / cplasma.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-03-31  |  11.2 KB  |  436 lines
  1. {$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q-,R-,S+,T-,V+,X+,Y+}
  2. {$M 64384,0,655360}
  3. Uses VgaGraph, Crt;
  4.  
  5. Const
  6.  RandInit : LongInt = 10;
  7.  MaxCol = 190;             {  Last Color  }
  8.  MinCol = 1;               {  First Color }
  9.  XMax = 319;
  10.  XHalf = XMax shr 1;
  11.  YMax = 199;
  12.  YHalf = YMax shr 1;
  13.  Roughness : Real = 10.0;  {  Default roughness  }
  14.  FadeOut : Real = 1.0;     {  Default fade value }
  15.  XAspect = 1.2;            {  Aspect Ratio  }
  16.  YAspect = 1.0;
  17.  Radii  : Integer = 32;
  18.  XRadii : Integer = 38;
  19.  YRadii : Integer = 32;
  20.  
  21. Var
  22.   ArcSinTab : Array[-90..90] of Real;  { -1 to +1 }
  23.   ArcCosTab : Array[0..180] of Real;   { +1 to -1 }
  24.   Aspects   : Boolean;                 { Use Square or Aspect? }
  25.   Nat_Plasm : Boolean;                 { Totally random? }
  26.   Centre    : Boolean;                 { Is the center random as well? }
  27.   PalDelay  : Word;
  28.  
  29. Procedure PrepPalette;
  30. {  Prepares the first VGA palette (fire like)  }
  31. var
  32.   b : Byte;
  33. begin
  34.   SetRGBPalette( 0, 0, 0, 0 );
  35.   For b := 0 to 63 do
  36.     SetRGBPalette( b+1, b, 0, 0 );
  37.   For b := 1 to 63 do
  38.     SetRGBPalette( b+64, 63, b, 0 );
  39.   For b := 1 to 63 do
  40.     SetRGBPalette( b+127, 63, 63, b );
  41.   SetRGBPalette( 191, 63, 0, 63 );
  42.   For b := 0 to 190 do
  43.     PutPixel( 0, b, b );
  44. end;
  45.  
  46. Procedure PrepPal;
  47. {  Prepares the second VGA palette.  }
  48. var
  49.   b : Byte;
  50. begin
  51.   For b := 0 to 63 do
  52.     SetRGBPalette( b+1, b, 0, 63-b );
  53.   For b := 1 to 63 do
  54.     SetRGBPalette( b+64, 63-b, b, 0 );
  55.   For b := 1 to 63 do
  56.     SetRGBPalette( b+127, 0, 63-b, b );
  57. end;
  58.  
  59. Function ArcSin( sn : Real ) : Integer;
  60. {  Returns the ArcSin of an angle.  }
  61. var
  62.   i     : Integer;
  63.   last  : Real;
  64.   lnum  : Integer;
  65. begin
  66.   lnum := -90;
  67.   last := Abs(sn - ArcSinTab[-90]);  {  Absolute difference  }
  68.   For i := -89 to 90 do
  69.     If Abs(sn-ArcSinTab[i])<last then
  70.       begin
  71.         last := Abs(sn-ArcSinTab[i]);
  72.         lnum := i;
  73.       end;
  74.   ArcSin := lnum;
  75. end;
  76.  
  77. Function ArcCos( sn : Real ) : Integer;
  78. {  Returns the ArcCos of an angle.  }
  79. var
  80.   i     : Integer;
  81.   last  : Real;
  82.   lnum  : Integer;
  83. begin
  84.   lnum := 0;
  85.   last := Abs(sn - ArcCosTab[0]);  {  Absolute difference  }
  86.   For i := 1 to 180 do
  87.     If Abs(sn-ArcCosTab[i])<last then
  88.       begin
  89.         last := Abs(sn-ArcCosTab[i]);
  90.         lnum := i;
  91.       end;
  92.   ArcCos := lnum;
  93. end;
  94.  
  95. Function Tan( x : Real ) : Real;
  96. {  Returns a tangent of an angle.  }
  97. begin
  98.   Tan := Sin(x)/Cos(x);
  99. end;
  100.  
  101. Function Radians( Ang : Real ) : Real;
  102. {  Converts degrees into radians.  }
  103. begin
  104.   Radians := Ang/180*Pi;
  105. end;
  106.  
  107. Function FindX( Ang, Rad : Real ) : Integer;
  108. {  Polar coordinates to cartesian coordinates.  }
  109. var
  110.   Tmp  : Integer;
  111.   Tmp2 : Real;
  112. begin
  113.   If Aspects then
  114.     FindX := Trunc(Cos(Ang/180*Pi)*Rad*XAspect)
  115.    else
  116.     FindX := Trunc(Cos(Ang/180*Pi)*Rad);
  117. end;
  118.  
  119. Function FindY( Ang, Rad : Real ) : Integer;
  120. {  Polar coordinates to cartesian coordinates.  }
  121. var
  122.   Tmp : Integer;
  123. begin
  124.   FindY := Trunc(Sin(Ang/180*Pi)*Rad);
  125. end;
  126.  
  127. Function RandOf( Relat : Byte; Len : Real ) : Byte;
  128. {  Adds an amount of randomness to Relat, depending on the distance Len.  }
  129. var
  130.   i : Integer;
  131. begin
  132.     i := Relat+Random(Trunc(Roughness*Len))-Trunc(Roughness*Len*0.5)-
  133.          Trunc(FadeOut*Len);
  134.   If i < 1 then
  135.     i := 1
  136.    else
  137.   If i > 190 then
  138.     i := 190;
  139.   RandOf := Byte(i);
  140. end;
  141.  
  142. Function Distance( x1, y1, x2, y2 : Integer ) : Real;
  143. {  Returns the distance between two points.  }
  144. begin
  145.   Distance := Sqrt( Sqr(x1-x2)+Sqr(y1-y2) );
  146. end;
  147.  
  148. Function ChordDist( x1, y1, x2, y2 : Integer; Dist : Real ) : Real;
  149. {  Returns the distance between two points on a chord.  }
  150. begin
  151.   ChordDist := (2*ArcSin( Distance(x1,y1,x2,y2)/(2*Dist) )*Pi*Sqr(Dist))/360;
  152. end;
  153.  
  154. Procedure LineOut( x1, y1, x2, y2 : Integer  );
  155. {  Creates the initial line axis of the circular plasma.  }
  156. Const
  157.   Sqrt2 = 1.4142135624;
  158. var
  159.   x3, y3 : Integer;
  160. begin
  161.   x3 := (x1+x2) div 2;  y3 := (y1+y2) div 2;
  162.   If ((x3<>x1) AND (x3<>x2)) OR ((y3<>y1) AND (y3<>y2)) then
  163.     begin
  164.       PutPixel( x3, y3, RandOf( (GetPixel(x1,y1)+GetPixel(x2,y2))div 2,
  165.                         Distance( x1, y1, x3, y3 ) ) );
  166.       LineOut( x1, y1, x3, y3 );
  167.       LineOut( x3, y3, x2, y2 );
  168.     end;
  169. end;
  170.  
  171. Var
  172.   WorryAng : Real;      {  Minimum angle that we have to worry about.  }
  173.   Quit     : Boolean;   {  Quitin' time.  }
  174.  
  175. Function NearIn( Angle, Radii : Real ) : Byte;
  176. {  Finds out what the nearest pixel at the same angle is equal to.  }
  177. var
  178.   x, y, i : Integer;
  179.   r, Len  : Real;
  180. begin
  181.   r := Radii;
  182.   Repeat
  183.     x := FindX( Angle, r );  y := FindY( Angle, r );
  184.     r := r - Sqrt(2);
  185.   Until GetPixel(x+XHalf,y+YHalf) > 0;
  186.   Len := Distance( FindX(Angle,Radii), FindY(Angle,Radii), x, y );
  187.   Repeat
  188.     i := GetPixel(x+XHalf,y+YHalf)+
  189.          Random(Trunc(Roughness*Len))-Trunc(Roughness*Len*0.5);
  190. {         Trunc(FadeOut*Len);}
  191.   Until (i < 191) AND (i > 0);
  192.   NearIn := Byte(i);
  193. end;
  194.  
  195. Procedure RoundOut( Ang1, Ang2, Rad : Real );
  196. {  Interpolates what (Ang1+Ang2)/2, Rad is equal to.  }
  197. var
  198.   Ang3 : Real;
  199. begin
  200.   If (Abs(Ang1-Ang2) > WorryAng) AND not Quit then
  201.     begin
  202.       Ang3 := (Ang1+Ang2)/2;
  203.       If GetPixel( FindX( Ang3, Rad )+XHalf, FindY( Ang3, Rad )+YHalf ) = 0 then
  204.         begin
  205. {          PutPixel( FindX(Ang3,Rad)+XHalf,FindY(Ang3,Rad)+YHalf, 191 );
  206.           Delay( 10 );
  207.           PutPixel( FindX(Ang3,Rad)+XHalf,FindY(Ang3,Rad)+YHalf, 0 );}
  208.           PutPixel( FindX(Ang3,Rad)+XHalf,FindY(Ang3,Rad)+YHalf,
  209.                  ((Integer(RandOf((GetPixel(FindX(Ang1,Rad)+XHalf,
  210.                  FindY(Ang1,Rad)+YHalf)+GetPixel(FindX(Ang2,Rad)+XHalf,
  211.                  FindY(Ang2,Rad)+YHalf)) shr 1,{Chord}Distance(FindX(Ang1,Rad),
  212.                  FindY(Ang1,Rad),FindX(Ang3,Rad),
  213.                  FindY(Ang3,Rad){,Rad}))) shl 1)+NearIn( Ang3, Rad )) div 3 );
  214.         end;
  215.       Quit := KeyPressed;
  216.       RoundOut( Ang1, Ang3, Rad );
  217.       RoundOut( Ang3, Ang2, Rad );
  218.     end;
  219. end;
  220.  
  221. Procedure Naturalness;
  222. {  Creates a random-based axis.  }
  223. begin
  224.   If Centre then
  225.     PutPixel( XHalf, YHalf, Random(190)+1 )
  226.    else
  227.     PutPixel( XHalf, YHalf, 190 );
  228.   PutPixel( XHalf+XRadii, YHalf, Random(190)+1-Trunc(Radii*FadeOut) );
  229.   PutPixel( XHalf-XRadii, YHalf, Random(190)+1-Trunc(Radii*FadeOut) );
  230.   PutPixel( XHalf, YHalf+YRadii, Random(190)+1-Trunc(Radii*FadeOut) );
  231.   PutPixel( XHalf, YHalf-YRadii, Random(190)+1-Trunc(Radii*FadeOut) );
  232. end;
  233.  
  234. Procedure RotatePal;
  235. {  Controls the various palette rotations  }
  236. type
  237.   rgbrec = record  r, g, b : Byte;  end;
  238. var
  239.   Pals     : Array[0..255] of RgbRec;
  240.   Tmp      : RgbRec;
  241.   i, j     : Integer;
  242. begin
  243.   For i := 0 to 255 do
  244.     GetRGBPalette( i, Pals[i].r, Pals[i].g, Pals[i].b );
  245.   Pals[1].r := 0;  Pals[1].g := 0;  Pals[1].b := 0;
  246.   For i := 1 to 190 do
  247.     SetRGBPalette( i, 0, 0, 0 );  {  Blank out palette.  }
  248.  
  249.   Repeat  {  Black, rotate in color, rotate out color, black.  }
  250.     For i := 1 to 190 do  {  Rotate in color  }
  251.       begin
  252.         For j := 1 to i do
  253.             SetRGBPalette( 190-i+j, Pals[j].r, Pals[j].g, Pals[j].b );
  254.         Delay( PalDelay );
  255.       end;
  256.     For i := 2 to 190 do  { Rotate through color  }
  257.       begin
  258.         For j := i to 190 do
  259.           SetRGBPalette( j-i+1, Pals[j-i+1].r, Pals[j-i+1].g, Pals[j-i+1].b );
  260.         SetRGBPalette( 192-i, 0, 0, 0 );
  261.         Delay( PalDelay );
  262.       end;
  263.     For i := 1 to 190 do  {  Black  }
  264.       SetRGBPalette( i, 0, 0, 0 );
  265.   Until UpCase(ReadKey) in ['Q',#27];  {  Until the ESC or Q key.  }
  266.  
  267.   Repeat  {  Rotate colors one way...  }
  268.     Tmp := Pals[1];
  269.     Move( Pals[2], Pals[1], 189*3 );
  270.     Pals[190] := Tmp;
  271.     For i := 1 to 190 do
  272.       SetRGBPalette( i, Pals[i].r, Pals[i].g, Pals[i].b );
  273.     Delay( PalDelay );
  274.   Until KeyPressed;
  275.   ReadKey;
  276.  
  277.   Repeat  {  Rotate colors the other way...  }
  278.     Tmp := Pals[190];
  279.     Move( Pals[1], Pals[2], 189*3 );
  280.     Pals[1] := Tmp;
  281.     For i := 1 to 190 do
  282.       SetRGBPalette( i, Pals[i].r, Pals[i].g, Pals[i].b );
  283.     Delay( PalDelay );
  284.   Until KeyPressed;
  285.   ReadKey;
  286.  
  287.   PrepPal;  {  A new palette to play with.  }
  288.   For i := 0 to 255 do 
  289.     GetRGBPalette( i, Pals[i].r, Pals[i].g, Pals[i].b );
  290.   Repeat  {  Forward through the colors.  }
  291.     Tmp := Pals[1];
  292.     Move( Pals[2], Pals[1], 189*3 );
  293.     Pals[190] := Tmp;
  294.     For i := 1 to 190 do
  295.       SetRGBPalette( i, Pals[i].r, Pals[i].g, Pals[i].b );
  296.     Delay( PalDelay );
  297.   Until KeyPressed;
  298.   ReadKey;
  299.  
  300.   Repeat  {  Backward through the colors.  }
  301.     Tmp := Pals[190];
  302.     Move( Pals[1], Pals[2], 189*3 );
  303.     Pals[1] := Tmp;
  304.     For i := 1 to 190 do
  305.       SetRGBPalette( i, Pals[i].r, Pals[i].g, Pals[i].b );
  306.     Delay( PalDelay );
  307.   Until KeyPressed;
  308.   ReadKey;
  309.  
  310.   ReadKey;
  311. end;
  312.  
  313. Procedure Main;
  314. var
  315.   i : Real;
  316.   s : Real;
  317.   j : Integer;
  318. begin
  319.   InitGraph;
  320.   PrepPalette;
  321.   SetColor( 191 );
  322.   Line( XHalf+XRadii+1, YHalf+YRadii+1, xHalf+XRadii+1, YHalf-YRadii-1 );
  323.   Line( XHalf+XRadii+1, YHalf+YRadii+1, xHalf-XRadii-1, YHalf+YRadii+1 );
  324.   Line( XHalf-XRadii-1, YHalf-YRadii-1, xHalf+XRadii+1, YHalf-YRadii-1 );
  325.   Line( XHalf-XRadii-1, YHalf-YRadii-1, xHalf-XRadii-1, YHalf+YRadii+1 );
  326.   PutPixel( XHalf, YHalf, 190 );
  327.   If Nat_Plasm then
  328.     Naturalness;
  329.   LineOut( XHalf, YHalf, XHalf+XRadii, YHalf );  {  Create plasma axis.  }
  330.   LineOut( XHalf, YHalf, XHalf-XRadii, YHalf );
  331.   LineOut( XHalf, YHalf, XHalf, YHalf+YRadii );
  332.   LineOut( XHalf, YHalf, XHalf, YHalf-YRadii );
  333.   s := 0.707106781;  {  Minimum radius to worry about.  }
  334.   Quit := FALSE;
  335.   i := s;
  336.   Repeat
  337.     RoundOut( 0, 90, i );    {  Figgle out plasma from x to y degrees,  }
  338.     RoundOut( 90, 180, i );  {  at radius i  }
  339.     RoundOut( 180, 270, i );
  340.     RoundOut( 270, 360, i );
  341.     i := i + s  {  Radius increases.  }
  342.   Until i >= Radii;
  343.   Write(#7);  { Beep!  }
  344.   ReadKey;
  345.   SetRGBPalette( 0, 0, 0, 63 );  {  Show any "missed" spots.  }
  346.   Delay( 1000 );
  347.   SetRGBPalette( 0, 0, 0, 0 );
  348.   RotatePal;
  349.   CloseGraph;
  350. end;
  351.  
  352. Procedure ReadInput;
  353. var
  354.   s    : String;
  355.   i, e : Integer;
  356.   r    : Real;
  357.   c    : Char;
  358. begin
  359.   Writeln;
  360.   Write( 'Enter # for RandSeed, or nothing for random:  ' );
  361.   Readln( s );
  362.   Val( s, i, e );
  363.   If (s='') OR (e<>0) then
  364.     Randomize
  365.    else
  366.     Randseed := i;
  367.   Write( 'Roughness value [10.0]:  ' );
  368.   Readln( s );
  369.   Val( s, r, e );
  370.   If (s<>'') AND (e=0) then
  371.     Roughness := r;
  372.   Write( 'Radii (in pixels) [32]:  ' );
  373.   Readln( s );
  374.   Val( s, i, e );
  375.   If (s<>'') AND (e=0) then
  376.     Radii := i
  377.    else
  378.     Radii := 32;
  379.   If Radii > 100 then
  380.     Radii := 100;
  381.   Write( 'Fadeout Value [0.0]:  ' );
  382.   Readln( s );
  383.   Val( s, r, e );
  384.   If (s<>'') AND (e=0) then
  385.     FadeOut := r
  386.    else
  387.     FadeOut := 0.0;
  388.   Write( 'Ejection Angle [0.6]:  ' );
  389.   Readln( s );
  390.   Val( s, r, e );
  391.   If (s<>'') AND (e=0) AND (r > 0) then
  392.     WorryAng := r
  393.    else
  394.     WorryAng := 0.6;
  395.   Write( 'Delay in palette rotation (ms) [5]:  ' );
  396.   Readln( s );
  397.   Val( s, i, e );
  398.   If (s<>'') AND (e=0) then
  399.     PalDelay := Abs(i)
  400.    else
  401.     PalDelay := 5;
  402.   Write( 'Correct the screen aspect?  <Y/N>' );
  403.   Repeat
  404.     C := UpCase( ReadKey );
  405.   Until C in ['Y','N'];
  406.   Aspects := C = 'Y';
  407.   If Aspects then
  408.     begin
  409.       XRadii := Trunc(1.2*Radii);
  410.       YRadii := Radii;
  411.     end
  412.    else
  413.     begin
  414.       XRadii := Radii;
  415.       YRadii := Radii;
  416.     end;
  417.   Write( #13, #10, 'Use random colors for the endpoints?  <Y/N>' );
  418.   Repeat
  419.     C := UpCase( ReadKey );
  420.   Until C in ['Y','N'];
  421.   Nat_Plasm := C = 'Y';
  422.   If Nat_Plasm then
  423.     begin
  424.       Write( #13, #10, 'Use a random color for the center?  <Y/N>' );
  425.       Repeat
  426.         C := UpCase( ReadKey );
  427.       Until C in ['Y','N'];
  428.       Centre := C = 'Y';
  429.     end;
  430. end;
  431.  
  432. Begin
  433.   ReadInput;
  434.   Main;
  435. End.
  436.